home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
akcl1615.lha
/
lsp
/
fasd.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1990-08-15
|
5KB
|
152 lines
(in-package 'si)
(require "FASDMACROS" "../cmpnew/fasdmacros.lsp")
;; (test '(a (1)) 2 12.0) --> ((a (1)) 2 12.0)
(defmacro dprint (x)
`(if (and (boundp 'debug) debug)
(format t "~%The value of ~a is ~s" ',x ,x)))
(defun keep (x) (setq sil x))
(defun test (&rest l &aux tab)
(with-open-file (st "/tmp/foo.l"
:direction :output )
(let* ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq)))))
(declare (special *fd*))
(si::find-sharing-top l tab)
; (preprocess l tab)
(sloop::sloop for v in l
do
(write-fasd-top v fd)
finally (close-fasd fd))))
(test-in))
(defun preprocess1(lis table)
(cond ((symbolp lis)
(and lis
(let ((tem (gethash lis table)))
(cond (tem
(if (< (the fixnum tem) 0)
(setf (gethash lis table) (the fixnum (+ (the fixnum tem) -1)))))
(t (setf (gethash lis table) -1))))))
((consp lis)
(preprocess1 (car lis) table)
(preprocess1 (cdr lis) table))
((and (arrayp lis)
(eq (array-element-type lis) t))
(sloop::sloop for i below (length lis)
do (preprocess1 (aref (the (array t) lis) i) table)))
((and (arrayp lis)
(eq (array-element-type lis) t))
(sloop::sloop for i below (length lis)
do (preprocess1 (aref (the (array t) lis) i) table)))
(t nil)))
(defun preprocess (lis table &aux freq)
(preprocess1 lis table)
(sloop:sloop for (ke val) in-table table
with m = 0 declare (fixnum m)
do ;(print (list ke val))
(cond((> (the fixnum val) 0)
(SETQ m (the fixnum (+ 1 m))))
((< (the fixnum val) -1)
(remhash ke table)
(push (cons val ke) freq)))
finally (sloop::loop-return
(sort freq '> :key 'car ))))
(defun test-in ()
(with-open-file (st "/tmp/foo.l" :direction :input)
(let ((fdin (open-fasd st :input (setq eof '(nil)) (keep (make-array 10)))))
(sloop while (not (eq eof (setq tem (read-fasd-top fdin))))
collect tem
finally
(dprint fdin)
(close-fasd fdin)))))
(defun try-write (file &aux (tab (make-hash-table :test 'eq)) (eof '(nil)))
(with-open-file (st file)
(with-open-file (st1 "/tmp/foo.l" :direction :output)
(sloop while (not (eq eof (setq tem (read st nil eof)))) with fd
collect (file-position st1)
do(clrhash tab)
(setq fd (open-fasd st1 :output nil tab))
; (let ((prp (preprocess tem tab)))
; (dprint prp))
(write-fasd-top tem fd)
(close-fasd fd)
(dprint tab)
))))
(defvar *differed* nil)
(defun try-read (file pos &aux (tab (make-array 10)) (eof '(nil)))
(with-open-file (st file)
(with-open-file (st1 "/tmp/foo.l")
(sloop while (not (eq eof (setq tem (read st nil eof)))) with fd with re
for u in pos
do (file-position st1 u)
(setq fd (open-fasd st1 :input eof tab))
(sloop::sloop for i below (length tab) do (setf (aref (the (array (t)) tab) i) nil))
(setq re (read-fasd-top fd))
(dprint re)
(unless (equalp tem re)
(push (list tem re) *differed*))
; (assert (eq eof (read-fasd-top fd)))
(close-fasd fd)))))
(defun try (file)
(let ((pos (try-write file)))
(try-read file pos)
(print file)
(system (format nil "cat ~a | wc ; cat /tmp/foo.l | wc " (namestring file)))
))
(defvar *table* (make-hash-table :test 'eq))
(defun do-share (x)
(si::find-sharing x *table*))
(defun read-data-file (file)
(let ((pack-ops))
(set-dispatch-macro-character #\# #\!
#'(lambda (st a b ) (setq pack-ops (read st nil nil) )))
(with-open-file (st file)
(let ((tem (read st nil nil)))
(list pack-ops tem)))))
(defun write-out-data (lis fil)
(with-open-file (st fil :direction :output)
(let ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq)))))
(find-sharing-top lis (fasd-table fd))
(write-fasd-top (car lis) fd)
(write-fasd-top (second lis) fd)
; (close-fasd fd)
fd)))
;; To convert an ascii .data file to a fasd one.
;(setq bil (si::read-data-file "vmlisp.data") her nil)
;(SI::WRITE-OUT-DATA1 (SECOND BIL) (FIRST BIL) "/tmp/foo.l")
(defun write-out-data1 (data-vec pack-ops fil)
(with-open-file (st fil :direction :output)
(let ((compiler::*data* (list data-vec nil pack-ops))
(compiler::*compiler-output-data* st)
(compiler::*fasd-data* (list (open-fasd st :output nil nil))))
(compiler::wt-fasd-data-file)
(car compiler::*fasd-data*))))
;(setq dirs (directory "/public/spad/libraries/A*/index.KAF*"))
;(mapcar 'try dirs)